home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1992 June: ROMin Holiday / ADC Developer CD (1992-06) (''ROMin Holiday'')_iso / Developer Connection - 06-1992.iso / Development Platforms / LISP Related / MCL Networking / Servers / server.lisp
Encoding:
Text File  |  1990-08-31  |  7.4 KB  |  168 lines  |  [TEXT/CCL ]
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;; Copyright 1987, 1988, 1989, 1990 by Ruben Kleiman for Apple Computer, Inc.
  3. ;;; Advanced Technology Group
  4.  
  5. ;;;
  6. ;;; Consult SAMPLE-SESSION.TXT file to see a live demo of how this works.
  7. ;;;
  8. ;;; Generic but simple network server for Allegro
  9. ;;;
  10.  
  11. (require :event)
  12.  
  13. (in-package :network :use '(lisp system ccl :event))
  14.  
  15. (export '(turn-server-on turn-server-off
  16.           turn-client-on turn-client-off
  17.           get-new-client define-server-medium))
  18.  
  19. ;;; Various supported network media are serviced through the generic
  20. ;;; functions defined in this file.  The lower-level protocols must simply
  21. ;;; be compatible with these calls.
  22.  
  23. ;;; A server is defined as a class (currently as an object lisp class object).
  24. ;;; Servers must support the following messages:
  25. ;;;   oneOf ::= used to create a server instance with arbitrary arguments
  26. ;;;   stream-open ::= initializes a server' storage and creates a logical connection (e.g., a socket)
  27. ;;;   server-on ::= makes the server active (e.g., by registering it)
  28. ;;;   server-off ::= makes the server inactive
  29. ;;;   stream-close ::= terminates a server's storage and logical connection
  30. ;;;   service ::= an efficient message which checks whether a connection request has been
  31. ;;;               received by the server and if so takes the appropiate action
  32.  
  33. (defobject *server* nil)
  34.  
  35. (defobfun (exist *server*) (init-list)
  36.   (usual-exist)
  37.   (have 'name (getf init-list :name "unknown"))                 ; server name
  38.   (have 'type (getf init-list :type "unknown"))                 ; server type
  39.   (have 'registered-p nil)         ; servers are registered by name and type
  40.   (have 'deny-connection! (getf init-list :deny-connection! nil)))    ; deny all connection requests
  41.  
  42. ;;; The *servers* hash table contains an entry for each server keyed on the server medium
  43. ;;; (e.g., ADSP, ATP, TCP), server name (e.g., "Mariani 2 1st fl") and type (e.g., "laser printer").
  44. ;;; The entry is the server instance object
  45. (defvar *servers* (make-hash-table :test #'equal))
  46.  
  47. ;;; This is an alist whose elements' car is a medium name and cadr is the medium server object class
  48. ;;; (e.g., for the ADSP medium: (:ADSP *adsp-server*))
  49. (defvar *supported-server-media* nil)
  50.  
  51.  
  52. ;;; Holds clients newly opened by servers; entries are stream objects whose class is
  53. ;;; a particular medium or protocol.  New streams may be pushed into *new-clients*
  54. ;;; by the service message of each server.
  55. (defvar *new-clients* nil)
  56.  
  57. (defun make-server (medium &rest init-list &aux server-medium)
  58.   "This is used to create a server object for the appropiate medium"
  59.   (cond ((setq server-medium (assoc medium *supported-server-media*))
  60.          (apply #'oneOf `(,(cadr server-medium) ,@init-list)))
  61.         ((cerror "IGNORE ERROR & CONTINUE..." "Medium ~a not supported" medium))))
  62.  
  63. (defun get-server (medium &key name type)
  64.   (gethash (read-from-string
  65.             (concatenate 'simple-string (symbol-name medium) name type))
  66.            *servers*))
  67.  
  68. (defun remove-server (medium &key name type)
  69.   (remhash (read-from-string
  70.             (concatenate 'simple-string (symbol-name medium) name type))
  71.            *servers*))
  72.  
  73. (defun number-of-servers ()
  74.   (hash-table-count *servers*))
  75.  
  76. (defun add-server (server medium &key name type)
  77.   (setf (gethash (read-from-string
  78.                   (concatenate 'simple-string (symbol-name medium)    ; consing doesn't work yet...
  79.                                name
  80.                                type))
  81.                  *servers*)
  82.         server))
  83.  
  84. (defun turn-server-on (medium &rest service-attributes &aux server)
  85.   (setq server (apply #'make-server `(,medium ,@service-attributes)))
  86.   (ask server (stream-open))
  87.   (ask server (server-on))
  88.   (unless (is-eventhook '(check-servers))
  89.     (add-eventhook '(check-servers) :fast))
  90.   (add-server server medium
  91.               :name (getf service-attributes :name "unknown")
  92.               :type (getf service-attributes :type "unknown"))
  93.   server)
  94.  
  95. (defun turn-server-off (medium &key name type &aux server)
  96.   (setq server 
  97.         (get-server medium :name name :type type))
  98.   (cond (server
  99.          (ask server (server-off))
  100.          (ask server (stream-close))
  101.          (remove-server medium :name name :type type)
  102.          (if (= 0 (number-of-servers))
  103.            (remove-eventhook '(check-servers) :fast)))
  104.         (t 
  105.          (cerror "IGNORE ERROR & CONTINUE..." "~a Server ~a not found" type name)))
  106.   server)
  107.  
  108. ;;; A more efficient version will be needed when many servers co-exist
  109. ;;; This gets called when each system event is processed
  110. (defun check-servers ()
  111.   (maphash #'(lambda (key server)
  112.                (ask server (service)))   ; service must be F A   S           T
  113.            *servers*)
  114.   nil)  ; MUST return nil
  115.  
  116. ;;; See ADSP.LISP for the definition of the ADSP driver server
  117. (defmacro define-server-medium (medium (&body server-request-body) (&body server-error-body))
  118.   (unless (cadr (assoc medium *supported-server-media*))
  119.     (error "Medium ~a is unknown." medium))
  120.   (unless (string-equal (symbol-name (car server-request-body))
  121.                         "ON-CLIENT-REQUEST")
  122.     (error "First form must be an ON-CLIENT-REQUEST body."))
  123.   (unless (string-equal (symbol-name (car server-error-body))
  124.                         "ON-SERVER-ERROR")
  125.     (error "Second form must be a ON-SERVER-ERROR body."))
  126.   (unless (and (listp (cadr server-error-body))
  127.                (symbolp (caadr server-error-body)))
  128.     (error "ON-SERVER-ERROR's second form is reserved for the error code variable"))
  129.   `(defobfun (service (cadr (assoc ,medium *supported-server-media*))) ()
  130.      (cond ((= (%get-signed-word driver-pb $ioResult) 1))   ; still listening [frequent case] -- avoids a check
  131.            ((= (%get-signed-word driver-pb $ioResult) 0)    ; got request [rare]
  132.             (let ((the-client ,@(cdr server-request-body)))
  133.               (if (string-equal "STREAM"
  134.                                 (symbol-name (type-of the-client)))
  135.                 (push the-client *new-clients*)))
  136.             (server-listen))
  137.            (t  ; unsuccessful completion
  138.             (let ((,(caadr server-error-body) (%get-signed-word driver-pb $ioResult)))
  139.               ,@(cddr server-error-body))
  140.             (server-listen)))))
  141.  
  142. (defun get-new-client (&key server-name server-type)
  143.   "Returns a client which requested service type from server name"
  144.   (declare (object-variable service-name service-type))
  145.   (dolist (client *new-clients*)
  146.     (when (and (string= (ask client service-name) server-name)
  147.                (string= (ask client service-type) server-type)
  148.                (multiple-value-bind (state ignore1 ignore2 ignore3 ignore4)
  149.                                     (ask client (status))
  150.                  (eq state 'OPEN)))
  151.       (setq *new-clients* (delete client *new-clients*))
  152.       (return client))))
  153.  
  154. (defmacro turn-client-on (client-var medium &key server-name server-type)
  155.   (let ((stream-class (read-from-string (format nil "network::*~a-stream*"
  156.                                                 (symbol-name medium)))))
  157.     (unless (and (boundp stream-class)
  158.                  (string-equal "STREAM"
  159.                                (symbol-name (type-of (eval stream-class)))))
  160.       (error "Stream class for medium ~a is not defined." medium))
  161.     `(progn (setq ,client-var (oneof ,stream-class))
  162.             (ask ,client-var (stream-open ,server-name ,server-type)))))
  163.  
  164. (defmacro turn-client-off (client-var)
  165.   `(ask ,client-var (stream-close)))
  166.  
  167. (push :SERVER *features*)
  168. (provide :server)